package Firepear::Carrot::Handler;

use warnings;
use strict;

use Firepear::Carrot::Util;

=head1 NAME

Firepear::Carrot::Handler - Grammar Handler Superclass

=head1 VERSION

Version 1.000

=cut

our $VERSION = '1.000';


=head1 SYNOPSIS

This is the generic Handler superclass for Carrot's Grammarian. It
implements the baseline functionality and structure that all specific
handlers share.


=head1 CONSTRUCTOR

=head2 new

=cut

sub new {
  my ($class,%args) = @_;

  my $self = bless { node      => 0,
		     s         => 0,
		   }, $class;

  $class =~ /::(\w+)::(\w+)$/;
  $self->{metatype} = uc($1); # PRAGMA or HANDLER
  $self->{type}     = uc($2); # TRIGGER, TAG, ...

  $self->{mu} = $self->setmarkup($args{mu});

  return $self;
}



=head1 PARSING METHODS

=head2 lex

Assemble meaningful document chunks.

If a closing delimiter is detected, a status code of 3 will be set and
C<undef> will be returned, indicating that the currently open chunk
has ended, and the Grammarian's context stack should be popped.

Otherwise a new node (or node chunk) will be contructed and handed
back to the Grammarian.

If a terminal markup is found (meaning that the node has no content),
the handler's status will be set to 1, indicating complete parsing and
that the context stack should be popped.

If a terminal is not found, status will be 2, meaning that content is
inbound: the context stack should be left as-is and the DOM pointer
moved to this new node.

=cut

sub lex {
    my ($self,$l) = @_;
    $self->clearnode;
    return undef if $self->status;

    my $token = $l->current;
    unless (defined $token)
      { $self->status(99); return undef }

    # see if we're looking at a terminal
    if ($token =~ /$self->{mu}{c}$/) {
	return undef unless ($self->valid_ending_pos($l));
	$self->status(3); return undef;
    }

    # no; strip opening markup
    if ($self->{metatype} eq 'PRAGMA')
      {	$token =~ s/$self->{mu}{z}{o} $self->{mu}{z}{o}//x }
    else
      { $token =~ s/$self->{mu}{o}// }

    # test for valid opening location
    unless ($self->{type} eq 'TAG' or $l->prev eq "\n") {
	$self->{type} eq 'TRIGGER' ? $self->status(200) : $self->status(300);
	return undef;
    }

    # get element name, reference id, and lexer fileinfo data
    $self->get_nodeinfo($token,$l);
    return undef if $self->status;

    # process attributes
    until ($self->status) {
	$token = $l->fetch;

	return undef if ($self->status >= 100);
	last unless (defined $token);

	next if ($token =~ /^[\s\n]+$/);       # ignore whitespace and newlines
	$token = $self->commenter($l,$self->{mu}{r}); # handle comments
	next if $token eq '';

	# we're done if we're looking at a terminal
	if ($token =~ /^$self->{mu}{c}/) { 
            return undef unless ($self->valid_ending_pos($l));
            $self->status(1); last
        }

	# have buildattr assemble if token looks like an attribute
	if ($token =~ /^\S+? $self->{mu}{s} [\S$self->{mu}{q}]/x)
	  { $self->buildattr($l) }
	else  # ...we're looking at content
	  { $self->status(2) unless $self->status; }
    }

    # if status isn't set yet, see if the lexer status is set
    unless ($self->status)
      { $self->status(99) if ($l->status > 99); }
    # and report failure if any bad statuses have been set
    return undef if ($self->status >= 99);

    # per-handler custom lexxing
    $self->lex_local($l);

    # rollback lexer if we've done partial parsing
    $l->settoken( cur => $l->prev, next => $l->current )
      if ($self->status == 2);

    return $self->{node};
}

=head2 lex_local

Second stage lexxing. Each handler implements this differently. Stub
version does nothing.

=cut

sub lex_local { return }

=head2 buildattr

Analyses and/or synthesizes tokens into key/value attribute pairs.

=cut

sub buildattr {
    my ($self,$l) = @_;
    return if ($self->status >= 9);

    my $s = $self->{mu}{s};
    my $q = $self->{mu}{q};
    my $endquote = 0;

    my $token = $l->current;
    if ($token =~ /$self->{mu}{c}/) {
	$token =~ /^(.+?) ($self->{mu}{c}) (.+)?$/x;
        $token = $1;
	$l->settoken(cur => $token, next => $3) if $3;
	$l->settoken(cur => $token, next => $2);
    }

    my ($attrib,$value) = split(/$s/,$token);
    $attrib = lc($attrib);

    # test for null name/values
    if ($attrib eq '')
      { $self->status(103); return undef }
    if ($value eq '')
      { $self->status(102); return undef }


    # if unquoted (or fully quoted), we're done
    unless ($value =~ /^$q/ and $value !~ /$q$/) {
      $value =~ s/^$q//; $value =~ s/$q$//;
      push @{ $self->{node}{attrs} }, ($attrib, $value);
      return;
    }

    # quoted; assemble
    $value =~ s/^$q//;
    until ($endquote) {
	$token = $l->fetch;
	last unless defined $token;
	if ($token =~ /$self->{mu}{c}/) {
	    unless ($token =~ /$q $self->{mu}{c}/x)
	      { $self->status(104); return undef }
            $token =~ /^(.+?) ($self->{mu}{c}) (.+)?$/x;
            $token = $1;
            $l->settoken(cur => $token, next => $3) if $3;
            $l->settoken(cur => $token, next => $2);
	}
	if ($token =~ /$q$/)
	  { $token =~ s/$q$//; $endquote = 1 }
	$value = join '', $value, $token;
    }

    return if ($l->status >= 99);

    push @{$self->{node}{attrs}}, ($attrib, $value);
}

=head2 valid_ending_pos

Returns C<1> if Trigger/Pragma terminal markups are at end-of-line.

Sets error status code and returns 0 otherwise.

=cut

sub valid_ending_pos {
    my ($self,$l) = @_;
    my $token = $l->current;

    # TRIGGER and PRAGMA endings must be last on line (except whitespace)
    if ($self->{type} eq 'TRIGGER' or $self->{metatype} eq 'PRAGMA') {
        unless ($l->status == 99) {
            unless ($token =~ /$self->{mu}{c}$/)
              { $self->status(201); return 0 }
            my $lookahead = $l->fetch;
            until ($lookahead eq "\n") {
                if ($lookahead !~ /^\s+$/)
                  { $self->status(201); return 0 }
                $lookahead = $l->fetch;
            }
            $l->settoken(cur => $token, next => "\n");
        }
    }

    # strip our markup and inject the rest of the token into the stream
    # (nested closings; inline tags)
    $token =~ s/^($self->{mu}{c})//;
    $l->settoken(cur => $1, next => $token) if $token;

    return 1;
}

=head2 handles

Determines if this Handler is the handler for a passed token (which
is, generally, to say, markup). Returns 1 or 0 for "yes" or "no".

=cut

sub handles {
    my ($self,$token) = @_;
    my $type = $self->{type};
    my $open = $self->{mu}{o}; my $close = $self->{mu}{c};
    my $singlo = $self->{mu}{z}{o};
    my $singlc = $self->{mu}{z}{c};

    unless ($token =~ /^$singlo.{1,2}$singlc$/) { # skip entities
	if ($self->{metatype} eq 'PRAGMA') {
	    return 1 if $token =~ /^$open/;
	} elsif ($type eq 'VERBATIM' or $type eq 'TRIGGER' or $type eq 'TAG') {
	    return 1 if $token =~ /^$open [^\s$singlo]/x;
	    return 1 if $token =~ /^$close/;
	}
    }
    return 1 if ($type eq 'TEXT' or $type eq 'VERBATIMTEXT');

    return 0; # generic Handler
}


=head1 UTILITY METHODS

=head2 clearnode

Resets the object's node storage hashref and wipes status if it is 1
or 2.

=cut

sub clearnode {
    my ($self) = @_;

    $self->{s} = 0 if ($self->{s} == 1 or $self->{s} == 2 or $self->{s} == 3);
    return if ($self->status >= 9);

    $self->{node} = { type    => undef,
		      finfo   => undef,
		      element => undef,
		      refid   => undef,
		      content => undef };
    $self->{node}{attrs} = []
      unless ($self->{type} eq 'TEXT' or $self->{type} eq 'VERBATIMTEXT');

}

=head2 get_nodeinfo

Performs initial assembly of the C<node> construct. Sets the element
name, the C<refid> if one is given, the node type, and gets file info
from the Lexer.

=cut

sub get_nodeinfo {
    my ($self,$token,$l) = @_;

    if ($token eq '')
      { $self->status(100); return }

    if ($token =~ /$self->{mu}{s}/) {
	($self->{node}{element}, $self->{node}{refid}) =
	  split(/$self->{mu}{s}/,$token);
	if ($self->{node}{refid} eq '')
	  { $self->status(101); return }
    } else {
	$self->{node}{element} = $token;
    }
    if ($self->{node}{element} eq '')
      { $self->status(100); return }

    my $fileinfo = $l->fileinfo;
    $self->{node}{finfo} = [ $fileinfo->{fnum}, $fileinfo->{lnum} ];

    $self->{node}{type}  = $self->{type};
}

=head2 setmarkup

Generates escaped markup delimiters for the object. Returns a hashref
of markups.

    { o => #open,
      c => #close,
      s => #separator,
      r => #remark (comment),
      q => #quote,
      z => #hashref of escaped single mu chars {o, c, i} }

=cut

sub setmarkup {
    my ($self, $mu) = @_;

    # catch null markups
    unless (defined $mu and @{$mu} == 5)
      { $self->status(901); return }

    # validate markup
    for my $char ( @$mu ) {
	if ($char =~ /[\d\s\nswbd]/ or $char eq '')
	  { $self->status(902); return }
    }

    my %markup = ( q => "\\" . $mu->[3],
		   r => join("\\", '', $mu->[2], $mu->[2], $mu->[2]),
		   s => "\\" . $mu->[2], );

    $markup{z} = { o => "\\" . $mu->[0],
		   c => "\\" . $mu->[1],
		   i => "\\" . $mu->[4] };

    $self->setmarkup_local($mu, \%markup);

    return \%markup;
}

=head2 setmarkup_local

Performs handler-specific markup initialization.

=cut

sub setmarkup_local {
    my ($self, $mu, $markup) = @_;

    $markup->{o} = join('\\', '', $mu->[0], $mu->[0]);
    $markup->{c} = join('\\', '', $mu->[1], $mu->[1]);
}


=head1 AUTHOR

Shawn Boyette, C<< <mdxi@cpan.org> >>

=head1 BUGS

Please report any bugs or feature requests at
L<http://carrot.googlecode.com>.  I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

=head1 COPYRIGHT & LICENSE

Copyright 2008 Shawn Boyette

All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of the <ORGANIZATION> nor the names of its
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

=cut

1; # End of Firepear::Carrot::Handler
